perm filename PLTCMD.OLD[MSS,LCS]1 blob sn#107284 filedate 1974-06-15 generic text, type T, neo UTF8
C**** PLTCMD, FILLER, NNN, UNPACK, ROFF ********
	SUBROUTINE PLTCMD
CC	IMPLICIT INTEGER(A-Q,S-Z)
	COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
	DIMENSION NMS(8),RMOV1(8),RMOV2(8)
	COMMON /DL/X22,SAVER,NAME /ALF/INP(3),ML
	COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
	EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
	1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(I3,INP(3))
	F78F(1)='(78F)'
	FA5(1)='(A5) '
	FA1(1)='(A1) '

	IF(I2.NE.'X')GO TO 1
CC	ML=' '
	I2=0
	RXC=0
	RMOV1(1)='Y'
	NAME=0
14	KA=0
3	KA=KA+1
CC	IF(ML.EQ.' ')GO TO 15
	IF(ML.EQ.0)GO TO 15
	K=K-2
	ML=ML-1
	IF(ML.EQ.0)GO TO 10
	GO TO 31
15	TYPE 2,KA
	ACCEPT 11,K,ML
C  TYPE LAST NAME, NUMBER  FOR A SERIES
50	IF(K.EQ.' ')GO TO 10
	IF(K.EQ.'99')GO TO 140
C  99=BACKUP
31	IF(LOOKD(K))GO TO 56
C JUMP IF FILE FOUND
	TYPE 55
	GO TO 15
55	FORMAT(' FILE NOT FOUND'/)
11	FORMAT(A5,I)
56	NMS(KA)=K
CC	IF(ML.EQ.' ')GO TO 5
	IF(ML.EQ.0)GO TO 5
	RJH='Y'
	GO TO 21
5	TYPE 8
	ACCEPT FA5,RJH
	IF(RJH.EQ.'99')GO TO 15
	IF(RJH.NE.'Y')RJH=0
	IF(RJH.EQ.0)REREAD F78F,RJH
C  MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
21	RMOV1(KA+1)=RJH
	RMOV2(KA)=RJH
	GO TO 3
140	KA=KA-1
	GO TO 15

10	KB=KA-1
	IF(I3.NE.'G')GO TO 22
	RSIZ=1
	GO TO 222
22	TYPE 9
	ACCEPT F78F,RSIZ
	IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
222	KA=0

1	IF(NAME.NE.0)GO TO 12
	IF(KA.EQ.KB)CALL EXITB
C  EXITB IS FOR FR80 RELEASE ****************
	NAME=NMS(KA+1)
	TYPE 111,NAME
	RETURN
12	KA=KA+1
	NAME=0
	RJD=1
	IF(INP(3).EQ.'C')RJD=0
C  'PXC' = CALCOMP OUTPUT
	RJH=0
	RJB=RSIZ
	RJC=RSIZ
	RJG=0
	RJE=1
	RJF=1
	IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
	IF(RMOV1(KA).NE.0)RJE=0
	IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
2	FORMAT(' TYPE FILE NAME',I2,1X$)
8	FORMAT(' MOVE UP AT END? ',$)
9	FORMAT(' SIZE FACTOR? ',$)
111	FORMAT(1XA5/)
	END
	SUBROUTINE OLDFIL(IFILL,QJB,QCENT,BX,BY)
	DIMENSION IFILL(1)
	COMMON /DL/IXRX,SAVER,NAME
	COMMON /SIZ/RSZ,JCEN,KCEN
	COMMON /FL/IC,N,NQ,RZ,XGP
	COMMON /STF/RSTFAC(8),RSTJC
	COMMON /PLTR/IPLT,RHT,DIS
	COMMON/DPY/IGO,RXGP,ITOP,IBOT
	PX=1
	IF(BX.EQ.0)BX=1
	IF(BY.EQ.0)BY=1
	IF(BX)PX=-1
	IXGP=XGP
	RSI=RSTJC*BY
C  RI IS INVERSION FACTOR
	BZ=BY/BX
	RT=RSTJC*BX
C  RS=HORIZ.    RT=VERT.
	JXGP=RXGP
	NX=2
C  NX IS POINTER IN X ARRAY
	ID=IFILL(NX)
	IF(IPLT)GO TO 101
	RBZ=QJB*RSZ
	RXX=RSZ*RT
C  WHAT ABOUT RXX???????? 
	RYX=QCENT*RSZ
	RXY=RSI*RSZ
	GO TO 100
101	RXX=RT*DIS
	RXY=RSI*RHT
	RBZ=QJB*DIS
	RYX=QCENT*RHT
100	RM=-1000
	IF(PX)RM=-RM
	I=NX+1
103	CALL UNPACK(IA,IB,IFILL(I))
	IF(IA.NE.IFILL(I+1)/10000)GO TO 102
	I=I+1
	GO TO 103
102	G=IA*RT+QJB
	H=IB*RSI+QCENT
	IF(IPLT)GO TO 200
	CALL LINES(G,H,3)
	GO TO 300
200	IF(IXRX.EQ.0)GO TO 90
	M=ROFF(-H*RHT+RXGP)
	N=ROFF(G*DIS+XGP)
	GO TO 80
90	M=ROFF(G*DIS)
	N=ROFF(H*RHT)
80	CALL PLOT(M,N,3)
300	NN=ID-1
C  LAST OF ARRAY-1
	P=IA*RXX
	CALL UNPACK(IG,H,IFILL(I+1))
	RB=IG*RXX+PX
	J=1
1	JJ=1
	IF(PX)GO TO 30
	IF(RM.GT.RB)GO TO 13
	GO TO 31
30	IF(RM.LT.RB)GO TO 13
31	IF(J)GO TO 2
3	CALL NNN(NN,1,0,IFILL)
C  FINDS BOTTOM POINTER
	GO TO 16	
2	CALL NNN(I,0,1,IFILL)
C  FINDS TOP POINTER(I)
16	CALL UNPACK(JAX,JB,IFILL(N))
	CALL UNPACK(JG,JH,IFILL(N+1))
	CALL UNPACK(IQ,H,IFILL(NQ))
	RZ=RZ*RXX
10	RDIS=JAX-JG
	IF(PX)GO TO 32
	IF(P.GT.RZ)P=RZ
	GO TO 33
32	IF(P.LT.RZ)P=RZ
C  REVERSES VERT.
33	Q=IQ*RXX
	C=IC*RXY+RYX
	IF(RDIS.NE.0)GO TO 6
C  FOR STRAIIGHT UP-DOWN LINES
	IF(NN-1.EQ.I)GO TO 13
	P=P-PX
	GO TO 5
6	H=BZ*(JB-JH)/RDIS
11	HH=(P-Q)*H+C
	PP=P+RBZ
	IH=ROFF(HH)
	IP=ROFF(PP)
C  ROFF IS FOR ROUND-OFF ERRORS
	IF(IP.EQ.MP.AND.IH.EQ.MH)GO TO 180
	MP=IP
	MH=IH
C  OMITS REPEATED POINTS
	IF(IPLT)GO TO 17
CC	IF(RSZ.LE.0.8571)GO TO 34
CC	IP=IP-JCEN
CC	IH=IH-KCEN
CC34	CALL AVECT(IP,IH)
	CALL LINES(PP/RSZ,HH/RSZ,2)
	GO TO 180
17	IF(IXRX.EQ.0)GO TO 19
	K=IP
	IP=-IH+JXGP
C NO RNDOFF OR DIS-RHT FACTORS HERE YET.
	IH=K+IXGP
19	CALL PLOT(IP,IH,2)
180	JJ=JJ-1
	IF(JJ)GO TO 12
	RM=P
	P=P+PX
	IF(PX)GO TO 35
	IF(P.LT.RZ)GO TO 11
	GO TO 5
35	IF(P.GT.RZ)GO TO 11
5	IF(J)GO TO 4
	NN=NN-1
	IF(I.GT.NN)GO TO 13
	GO TO 3
4	I=I+1
	IF(I.GT.NN)GO TO 13
402	CALL UNPACK(IA,IB,IFILL(I+1))
	RB=IA*RXX+PX
	GO TO 2
12	J=-J
	GO TO 1
13	NX=ID+1
	IF(ID.EQ.IFILL(1))GO TO 130
	ID=IFILL(NX)
	GO TO 100
130	MP=1000
	MH=1000
	RETURN
	END

	SUBROUTINE NNN(J,L,K,IFILL)
	COMMON /FL/IC,N,NQ,RZ,XGP
	DIMENSION IFILL(1)
	CALL UNPACK(IZ,IC,IFILL(J+K))
	CALL UNPACK(N,IC,IFILL(J+L))
	N=J
C  C IS THE CONSTANT
	NQ=N+L
	RZ=IZ
	RETURN
	END

	SUBROUTINE UNPACK(M,N,I)
	COMMON/LL/L
C  L IS FOR VIS. OR INVIS. LINES.
	N=I
	L=2
	M=N/100000000
	IF(M.EQ.0)GO TO 2
	L=3
	N=N-100000000*M
2	M=N/10000
CC	N=N-M*10000
	N=MOD(N,10000)
	IF(M.GT.1000)M=1000-M
	IF(N.GT.1000)N=1000-N
	END

	FUNCTION ROFF(R)
	S=.5
	IF(R)S=-S
	ROFF=R+S
	END

C******   CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
	SUBROUTINE FILLMS(L,IDAT,RJB,CENTR,RJF,RJG)
	COMMON/DL/IXRX,SAVER,NAME
	COMMON/DST/BB,CC/FLM/X(200),Y(200),NX(200)
	DIMENSION IDAT(1)
	COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJC
	DATA MP/2/,MD/6/
C MD=DISPLAY   MP=PLOTTER   MX=XGP
	DX=DIS
	RX=RHT
	D=RSTJC*RJF
	R=RSTJC*RJG
4	GO TO 1
	C=CC
	B=BB
C  SAVES IT.  IT WILL RETURN LATER.
	BB=B/DIS
	CC=1000
1	KK=0
	DO 205 J=1,L
	CALL UNPACK(M,N,IDAT(J))
	KK=KK+1
	NX(KK)=0
	IF(LL.EQ.3)NX(KK)=3
	X(KK)=ROFF((RJB+D*M)*DIS)
	Y(KK)=ROFF((CENTR+R*N)*RHT)
3	GO TO 205
	Y(KK)=Y(KK)*(C-BB*(ABS(X(KK))))
C  FOR DISTORTION
205	CONTINUE
	NX(1)=KK
	DIS=1.0
	RHT=DIS
	M=MD
	IF(IPLT)M=MP-IXRX
C  STOPS DISTORTION IN 'LINES'
2	CALL FILLER(X,Y,NX,M)
	DIS=DX
	RHT=RX
5	RETURN
C  NEXT TO RESET DISTORTION FACT.
	BB=B
	CC=C
	RETURN
	END

	SUBROUTINE ROTATE(I,L,DEG)
	DIMENSION I(1)
	N=I(L)
	KNT=501
C  ROTATED DATA IS PUT BACK STARTING AT LOCATION 501.
	I(KNT)=N
	DO 1 K=L+1,N+L-1
	CALL UNPACK(J,M,I(K))
	X=J
	Y=M
	JJ=I(K)/100000000
	AX=ATAN2(X,Y)*57.29578
	HYP=SQRT(X**2+Y**2)
	ROT=DEG+AX
	J=ROFF(HYP*COSD(ROT))
	M=ROFF(HYP*SIND(ROT))
	KNT=KNT+1
	IF(J)J=1000-J
	IF(M)M=1000-M
1	I(KNT)=M*10000+J+JJ*100000000
	L=501
	END